SuperHack/SuperHack CD.bin/CODING/VBASIC/DISSOL32.ZIP/DSLVEXP.FRM

Visual Basic Form | 1995-07-31 | 5.2 KB | 165 lines

VERSION 4.00
Begin VB.Form Disolve1
   Caption         =   "Bitmap Dissolve Experiment"
   ClientHeight    =   4710
   ClientLeft      =   1050
   ClientTop       =   1590
   ClientWidth     =   8205
   DrawMode        =   9  'Not Mask Pen
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   0
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   Height          =   5160
   Left            =   990
   LinkTopic       =   "Form1"
   ScaleHeight     =   314
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   547
   Top             =   1200
   Width           =   8325
   Begin VB.CommandButton DissolveButton
      Caption         =   "Do Dissolve"
      Height          =   432
      Left            =   3240
      TabIndex        =   2
      Top             =   4140
      Width           =   1632
   End
   Begin VB.PictureBox Picture2
      Height          =   3912
      Left            =   4260
      Picture         =   "dslvexp.frx":0000
      ScaleHeight     =   257
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   253
      TabIndex        =   1
      Top             =   120
      Width           =   3852
   End
   Begin VB.PictureBox Picture1
      AutoRedraw      =   -1  'True
      Height          =   3912
      Left            =   120
      Picture         =   "dslvexp.frx":9682
      ScaleHeight     =   257
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   253
      TabIndex        =   0
      Top             =   120
      Visible         =   0   'False
      Width           =   3852
   End
   Begin VB.Timer Timer1
      Enabled         =   0   'False
      Interval        =   56
      Left            =   3120
      Top             =   2640
   End
Attribute VB_Name = "Disolve1"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Dim hBrush As Variant
Dim PixelSetSequence(64) As Integer
Dim DissolveStep As Integer
Const NumberOfSteps = 8
Private Function CreateDissolveBrush(DissolveStep As Integer) As Integer
Dim hCompBitmap As Long
Dim BrushBitmapInfo As BITMAPINFO
Dim Counter As Integer
Dim PixelData As String * 32
Dim Dummy As Long
Dim Row As Integer
Dim Column As Integer
   With BrushBitmapInfo.bmiHeader
      .biSize = 40
      .biWidth = 8
      .biHeight = 8
      .biPlanes = 1
      .biBitCount = 1
      .biCompression = 0
      .biSizeImage = 0
      .biXPelsPerMeter = 0
      .biYPelsPerMeter = 0
      .biClrUsed = 0
      .biClrImportant = 0
   End With
   ' Set the color table values for
   ' the brush to black and white.
   With BrushBitmapInfo.bmiColors(0)
      .rgbBlue = 0
      .rgbGreen = 0
      .rgbRed = 0
      .rgbReserved = 0
   End With
   With BrushBitmapInfo.bmiColors(1)
      .rgbBlue = 255
      .rgbGreen = 255
      .rgbRed = 255
      .rgbReserved = 0
   End With
   ' Initialize brush bitmap pixel data to all white.
   For Counter = 0 To 7
      Mid$(PixelData, Counter * 4 + 1, 1) = Chr$(&HFF)
   Next Counter
   ' Set the bits representing the black pixels to 0.
   For Counter = 1 To DissolveStep * (64 / NumberOfSteps)
      Row = (PixelSetSequence(Counter) - 1) \ 8
      Column = (PixelSetSequence(Counter) - 1) Mod 8
      Mid$(PixelData, Row * 4 + 1, 1) = Chr$(Asc(Mid$(PixelData, Row * 4 + 1, 1)) And (Not (2 ^ Column)))
   Next Counter
   '  Convert the DIB into a DDB and create the pattern brush.
   hCompBitmap = CreateDIBitmap(Disolve1.hDC, BrushBitmapInfo.bmiHeader, CBM_INIT, PixelData, BrushBitmapInfo, DIB_RGB_COLORS)
   CreateDissolveBrush = CreatePatternBrush(hCompBitmap)
   Dummy = DeleteObject(hCompBitmap)
End Function
Private Sub CreatePixelSetSequence()
Dim Counter As Integer
Dim PixelNumberString As String * 5
Const PixelListFile = 1
   Open App.Path & "\PixelLst.TXT" For Input As #PixelListFile
   For Counter = 1 To 64
      Input #PixelListFile, PixelNumberString
      PixelSetSequence(Counter) = Val(PixelNumberString)
   Next Counter
End Sub
Private Sub DissolveButton_Click()
   DissolveButton.Enabled = False
   Timer1.Enabled = True
End Sub
Private Sub Form_Load()
   CreatePixelSetSequence
   DissolveStep = 0
End Sub
Private Sub Picture2_Click()
   If DissolveStep < NumberOfSteps Then
      DissolveStep = DissolveStep + 1
      Picture2_Paint
   End If
End Sub
Private Sub Picture2_Paint()
Dim hRgn As Long
Dim Dummy As Long
Dim hOldBrush As Long
   hBrush = CreateDissolveBrush(DissolveStep)
   hOldBrush = SelectObject(Picture2.hDC, hBrush)
   Dummy = BitBlt(Picture2.hDC, 0, 0, Picture2.ScaleWidth, Picture2.ScaleHeight, Picture1.hDC, 0, 0, &HAC0744)
   'Dummy = StretchBlt%(Picture2.hDC, 0, 0, Picture2.ScaleWidth, Picture2.ScaleHeight, Picture1.hDC, 0, 0, Picture2.ScaleWidth, Picture2.ScaleHeight, &HAC0744)
   Dummy = SelectObject(Picture2.hDC, hOldBrush)
   Dummy = DeleteObject(hBrush)
End Sub
Private Sub Timer1_Timer()
   If DissolveStep < NumberOfSteps Then
      DissolveStep = DissolveStep + 1
      Picture2_Paint
   Else
      Timer1.Enabled = False
   End If
End Sub